Optional Vectors.f

{ Notes

X, Y, and Z are fixed-point.

Supports 2D and 3D operations.

}

Requires FixedPoint
Requires Structs
Requires A
Requires Tools

Only Forth Definitions

struct
  cell field ->x
  cell field ->y
  cell field ->z
end-struct /Vector

\ Interpret up to 3 values and place in dictionary - any code is allowed so long as it adds 0 to 3 items to the stack.
: coords   ( stopper -- addr )
  locals| stopper |
  a@ >r  state @ >r   state off
    here 3 cells /allot
    a!
    a@ >r depth >r
      stopper parse evaluate
    depth r> - dup >r reverse r> 0 ?do !a+ loop
    r>
  r> state !   r> a!  ;

\ Simple literal-vector / literal-array structure creator
: Vector:
  create  [char] ; coords drop ;

Vector: tempv   0.0 0.0 0.0  ;

\ Inline vectors - NOTE these are compiled and not re-entrant !!!
{
: v[
  state @ if  postpone ahead  then
  [char] ] coords
  state @ if  swap >resolve  postpone literal then ; immediate
}

: 2v@   2@ swap ;
\ : 2v!   >r swap r> 2! ;
icode 2v!
  0 [ebp] eax mov
  4 [ebp] ecx mov
  eax 4 [ebx] mov
  ecx 0 [ebx] mov
  8 [ebp] ebx mov
  12 # ebp add
  ret end-code
\ : 2v+!   dup >r 2v@ 2+ r> 2v! ;
icode 2v+!
  0 [ebp] eax mov
  4 [ebp] ecx mov
  eax 4 [ebx] add
  ecx 0 [ebx] add
  8 [ebp] ebx mov
  12 # ebp add
  ret end-code

: 2v.   2v@ 2.. ;
: 2v@>f   @+ .>f @ .>f ;

: 3v@   @+ swap @+ swap @ ;
\ : 3v!   dup >r 8 + ! r@ cell+ ! r> ! ;
code 3v!
  0 [ebp] eax mov
  4 [ebp] ecx mov
  eax 8 [ebx] mov
  ecx 4 [ebx] mov
  8 [ebp] eax mov
  eax 0 [ebx] mov
  12 [ebp] ebx mov
  16 # ebp add
  ret end-code

\ : 3v+!   dup >r 8 + +! r@ cell+ +! r> +! ;
code 3v+!
  0 [ebp] eax mov
  4 [ebp] ecx mov
  eax 8 [ebx] add
  ecx 4 [ebx] add
  8 [ebp] eax mov
  eax 0 [ebx] add
  12 [ebp] ebx mov
  16 # ebp add
  ret end-code
: 3v.   3v@ 3.. ;
: 3v@>f   @+ .>f  @+ .>f @ .>f ;

{
icode 2v+
  0 [ebp] eax mov
  0 [eax] ecx mov
  ecx 0 [ebx] add
  4 [eax] ecx mov
  ecx 4 [ebx] add
  4 [ebp] ebx mov
  8 # ebp add
  ret end-code

code 3v+
  0 [ebp] eax mov
  0 [eax] ecx mov
  ecx 0 [ebx] add
  4 [eax] ecx mov
  ecx 4 [ebx] add
  8 [eax] ecx mov
  ecx 8 [ebx] add
  4 [ebp] ebx mov
  8 # ebp add
  ret end-code
}

{
: 2v+   ( addr addr -- )
  >r @+ r@ +!
  @ r> 4 + +! ;

: 3v+   ( addr addr -- )
  >r @+ r@ +!
  @+ r@ 4 + +!
  @ r> 8 + +! ;
}

: 2vcopy   ( src dest -- )
   8 move ;

: 3vcopy   ( src dest -- )
   12 move ;

: xy>ang   ( x. y. -- ang. )
   .>f .>f f/ fatan r>d f>. ;

: 2v>ang   ( addr -- ang. )
  @+ swap @ xy>ang ;

: ang>xy ( .angle .length -- x. y. )
   .>f
   .>f  ( f: length angle )
   f2dup ( f: length angle length angle )
   sin f* f>.
   cos f* f>. ;


: 2vscale   ( x. y. dest -- )
   >r  r@ ->y @ .* r@ ->y !
       r@ ->x  @ .* r> ->x ! ;

{
code 2vscale
  ebx ecx mov
  0 [ebp] eax mov
  4 [ecx] mul
  edx 4 [ecx] mov
  4 [ebp] eax mov
  0 [ecx] mul
  edx 0 [ecx] mov
  8 [ebp] ebx mov
  12 # ebp add
  ret end-code
}

: 3vscale   ( x. y. z. dest -- )
  a!
   a@ ->z @ .* a@ ->z !
   a@ ->y @ .* a@ ->y !
   a@ ->x @ .* a@ ->x ! ;

: 2scale   ( x. y. x. y. -- x. y. )
   rot .* >r .* r> ;

: 3scale   ( x. y. z. x. y. z. -- x. y. z. )
   3 roll .* >r
   rot .* >r .* r> r> ;

: 2length  ( x. y. -- n. )
   2.>f fdup f* fswap fdup f* f+ fsqrt f>. ;

:macro 2vlength  ( addr -- .n )   2v@ 2length ;

: 2vnormalize ( addr -- )
   1.0 over 2vlength dup if ./ dup tempv 2v! tempv swap 2vscale
   else 3drop then ;

: 2vnegate   dup @ negate !+ dup @ negate !+ drop ;
: 3vnegate   dup @ negate !+ dup @ negate !+ dup @ negate !+ drop ;

: 2rotate   ( x. y. angle. -- x. y. )
  dup .cos swap .sin locals| sin(ang) cos(ang) y x |
  x cos(ang) .* y sin(ang) .* -
  x sin(ang) .* y cos(ang) .* + ;

\ 2+ and 2- are obsolete Forth words.  I'm redefining them to something useful.

-? icode 2+  ( x. y. x. y. -- x. y. )
   0 [ebp] eax mov                  \ get d2-lo
   eax 8 [ebp] add                  \ add d1-lo
   4 [ebp] ebx add                  \ add d1-hi
   8 # ebp add                      \ and clean up stack
   ret end-code

-? icode 2-   ( x. y. x. y. -- x. y. )
   0 [ebp] eax mov
   ebx 4 [ebp] sub
   eax 8 [ebp] sub
   4 [ebp] ebx mov
   8 # ebp add
   ret end-code

-? icode 3+   ( x. y. z. x. y. z. -- x. y. z. )
   0 [ebp] eax mov
   4 [ebp] ecx mov
   ebx 8 [ebp] add
   eax 12 [ebp] add
   ecx 16 [ebp] add
   8 [ebp] ebx mov
   12 # ebp add
   ret end-code

-? icode 3-   ( x. y. z. x. y. z. -- x. y. z. )
   0 [ebp] eax mov
   4 [ebp] ecx mov
   ebx 8 [ebp] sub
   eax 12 [ebp] sub
   ecx 16 [ebp] sub
   8 [ebp] ebx mov
   12 # ebp add
   ret end-code

:macro 2proximity  ( x. y. x. y. -- n. )    2- 2length ;

: 2negate  negate swap negate swap ;


